home *** CD-ROM | disk | FTP | other *** search
/ CD Actual 9 / CDACTUAL9.iso / share / Dos / VARIOS / pascal / DIRS.SWG / 0005_Do a directory.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1996-02-21  |  2.6 KB  |  147 lines
  1.  
  2. program soupdir;  {do a directory, listing SOUP files}
  3.  
  4. {
  5. Russell_Schulz@alpha3.ersys.edmonton.ab.ca (950904)
  6.  
  7. Copyright 1995 Russell Schulz
  8.  
  9. this code is not in the Public Domain
  10.  
  11. permission is granted to use these routines in any application regardless
  12. of commercial status as long as the author of these routines assumes no
  13. liability for any damages whatsoever for any reason.  have fun.
  14. }
  15.  
  16. uses dos,genericf;
  17.  
  18. type
  19.   nodep=^node;
  20.   node=record
  21.       filename: string;
  22.       description: string;
  23.       next: nodep;
  24.     end;
  25.  
  26. var
  27.   head: nodep;
  28.  
  29. procedure die(s: string);
  30.  
  31. begin
  32.   writeln(s);
  33.   halt(1);
  34. end;
  35.  
  36. procedure usage;
  37.  
  38. begin
  39.   writeln('usage: SOUPDIR');
  40.   halt(2);
  41. end;
  42.  
  43. procedure lfreadln(var lff: text; var astring: string);
  44.  
  45. var
  46.   done: boolean;
  47.   c: char;
  48.  
  49. begin
  50.   astring := '';
  51.  
  52.   done := false;
  53.   while not done do
  54.     begin
  55.       if eof(lff) then
  56.         done := true
  57.       else if length(astring)>=255 then
  58.         done := true
  59.       else
  60.         begin
  61.           read(lff,c);
  62.           if c=#10 then
  63.             done := true
  64.           else if c<>#13 then
  65.             astring := astring+c;
  66.         end;
  67.     end;
  68. end;
  69.  
  70. procedure initialize;
  71.  
  72. var
  73.   areasf: text;
  74.   tempstring: string;
  75.   tempnodep: nodep;
  76.  
  77. begin
  78.   if paramcount<>0 then
  79.     usage;
  80.  
  81.   head := nil;
  82.  
  83.   assign(areasf,'AREAS');
  84. {$I-}
  85.   reset(areasf);
  86. {$I+}
  87.   if ioresult<>0 then
  88.     die('could not open AREAS file');
  89.  
  90.   while not eof(areasf) do
  91.     begin
  92.       lfreadln(areasf,tempstring);
  93.       new(tempnodep);
  94.  
  95.       tempnodep^.filename := chopfirstw(tempstring)+'.msg';
  96.       tempnodep^.description := chopfirstw(tempstring);
  97.  
  98.       tempnodep^.next := head;
  99.       head := tempnodep;
  100.     end;
  101.  
  102.   close(areasf);
  103. end;
  104.  
  105. procedure process;
  106.  
  107. var
  108.   fileinfo: searchrec;
  109.   filename: string;
  110.   tempnodep: nodep;
  111.  
  112. begin
  113.   findfirst('*.MSG',archive,fileinfo);
  114.   while doserror=0 do
  115.     begin
  116.       filename := lower(fileinfo.name);
  117.  
  118. {assume no packet will be bigger than a meg}
  119.       write(leftjustify(filename,12,' '),' ',fileinfo.size:6,' ');
  120.       tempnodep := head;
  121.       while tempnodep<>nil do
  122.         begin
  123.           if tempnodep^.filename=filename then
  124.             begin
  125.               write(copy(tempnodep^.description,1,50));
  126.               tempnodep := nil;
  127.             end
  128.           else
  129.             tempnodep := tempnodep^.next;
  130.         end;
  131.       writeln;
  132.       findnext(fileinfo);
  133.     end;
  134. end;
  135.  
  136. procedure shutdown;
  137.  
  138. begin
  139. end;
  140.  
  141. begin
  142.   initialize;
  143.   process;
  144.   shutdown;
  145. end.
  146. -- 
  147.